;; collection/vector.scm - (c) rohan drape, 2000-2005

;; SRFI-43 variants.

(define (vector-for-each* procedure . vectors)
  (apply vector-for-each (lambda a (apply procedure (cdr a))) vectors))

(define (vector-index/start+end predicate vector start end)
  (let loop ((index start))
    (cond ((= index end) #f)
	  ((predicate (vector-ref vector index)) index)
	  (else (loop (+ index 1))))))

;; SRFI-43 DRAFT procedures.

(define (vector-iota . args)
  (list->vector (apply iota args)))

;; SRFI-1 vector variants.

(define (vector-tabulate n f) (vector-unfold f n))
(define (vector-tabulate* n f) (vector-unfold (if (thunk? f) (lambda (i) (f)) f) n))

;; For each slot at `v' apply the procedure `p' to the index and the
;; slot value.  Evaluates to `v'.

(define (vector-traverse v p)
  (let ((n (vector-length v)))
    (do ((i 0 (+ i 1)))
	((= i n))
      (p i (vector-ref v i))))
  v)

;; Traverse `v' using `p' and write the result of the each operation
;; back into the slot.  Evaluates to `v'.

(define (vector-mutate! v p)
  (vector-traverse v (lambda (i e) (vector-set! v i (p i e)))))

;; Evaluate to a vector of `n' places that has at each element: 1. If
;; input is not a vector each element of the result vector is the
;; value `input'; 2. If input is a vector of `n' places the result
;; vector is `input'; 3. If input is a vector of `more than `n' places
;; an error is raised; 4. Else the result is a circular expansion of
;; `input'.

(define (vector-expand input n)
  (if (<= n 0)
      (error "vector-expand: extent <= 0")
      (if (not (vector? input))
	  (make-vector n input)
	  (let ((l (vector-length input)))
	    (cond ((= l n)
		   input)
		  ((> l n)
		   (error "vector-expand: expand depth less than input depth"))
		  (else
		   (let ((result (make-vector n)))
		     (do ((i 0 (+ i 1))
			  (j 0 (+ j 1)))
			 ((= i n) result)
		       (if (= j l)
			   (set! j 0))
		       (vector-set! result i (vector-ref input j))))))))))

;; Evaluates to a rotation of `v' by `n' places.

(define (vector-rotate v n)
  (let ((vl (vector-length v)))
    (vector-map (lambda (i index) 
		  (vector-ref v (modulo (+ n index) vl)))
		(list->vector (iota vl)))))

;; Evaluates to the element `n', modulo the length of `v', at `v'.

(define (vector-ref-wrap v n)
  (vector-ref v (modulo n (vector-length v))))

;; A vector-ref variant that wraps indices and allows non vector input.

(define (vector-at v n)
  (if (vector? v) (vector-ref-wrap v n) v))

;; Evaluates to the element `n' places from the end of `v'.

(define (vector-ref-right v n)
  (vector-ref v (- (- (vector-length v) n) 1)))

;; Evaluates to the element `n' places from the end of `v'.

(define (vector-set!-right v n k)
  (vector-set! v (- (- (vector-length v) n) 1) k))

;; Evaluates to a randomly selected element of the vector 'v'.

(define (vector-choose v)
  (vector-ref v (randomI-zero-right (vector-length v))))

;; Randomly re-order the elements of the vector `v'.  The two argument
;; procedure `random-left-right' should return a random integer in
;; [l,r).  This is a mutation operation.  Evaluates to the shuffled
;; vector.

(define (vector-shuffle! random-left-right v)
  (let ((n (- (vector-length v) 1)))
    (do ((i 0 (+ i 1))) ((< n i) v)
      (let* ((r (random-left-right i (+ n 1)))
	     (t (vector-ref v r)))
	(vector-set! v r (vector-ref v i))
	(vector-set! v i t)))
    v))

;; Apply `procedure' with the elements of `vector' as arguments.  The
;; vector variant of the R5RS procedure 'apply' procedure.

(define (vector-apply procedure vector)
  (apply procedure (vector->list vector)))

;; Evaluates to the first element in `vector' that evaluate to '#t'
;; under `predicate', or #f is no such element exists.  This is
;; inherently ambiguous.

(define (vector-find predicate vector)
  (let ((index (vector-index predicate vector)))
    (if index
	(vector-ref vector index)
	#f)))

;; Evaluates to #t iff all elements of `vector' evaluate to '#t' under
;; `predicate'.

(define (vector-uniform predicate vector)
  (let ((vector-n (vector-length vector)))
    (do ((index 0 (+ index 1))
	 (result #t))
	((or (not result) 
	     (= index vector-n)) result)
      (if (not (predicate (vector-ref vector index)))
	  (set! result #f)))))

;; If `v' is a vector evaluates to the length of `v', else to 1.

(define (vector-length-or-one v)
  (if (vector? v)
      (vector-length v)
      1))

;; If `v' is a vector evaluates to the `n'th element of `v', else if
;; `n' is zero to `v', else raises an error.

(define (vector-ref-or-object v n)
  (if (vector? v)
      (vector-ref v n)
      (if (= n 0)
	  v
	  (error "vector-ref-or-object: non-vector input and non-zero index"))))

;; Evaluate to a vector where every vector element at `input' is
;; flattened into the output vector.

(define (vector-flatten-one-layer input)
  (if (= 0 (vector-length input))
      input
      (let ((n (vector-apply +
			     (vector-map (lambda (i v)
					   (if (vector? v)
					       (vector-length v)
					       1))
					 input))))
	(let ((result (make-vector n)))
	  (do ((i 0 (+ i 1))
	       (j 0)
	       (k 0 (+ k 1))
	       (l (vector-length-or-one (vector-ref-or-object input 0))))
	      ((= i n) result)
	    (if (= k l)
		(begin
		  (set! j (+ j 1))
		  (set! k 0)
		  (set! l (vector-length-or-one (vector-ref input j)))))
	    (vector-set! result 
			 i 
			 (vector-ref-or-object 
			  (vector-ref input j) k)))))))

;; Evaluates to a one argument procedure to lookup y values at the x,y
;; transform function `data'.  `data' should be in ascending x order
;; and normal at x.  Out of range x lookups are clipped, ie. and x
;; less than zero gives the leftmost y, and x greater than one gives
;; the rightmost y.  A single point at `data' will cover all input x
;; values.  If `data' is illegal the lookup returns zero.

(define (vector-transfer-function-lookup data)
  (define (linear-interpolate left right index)
    (+ (* index (- right left)) left))
  (define (data-x index)
    (vector-ref data (* index 2)))
  (define (data-y index)
    (vector-ref data (+ (* index 2) 1)))
  (lambda (x)
    (let* ((size (vector-length data))
	   (half-size (/ size 2)))
      (cond ((= half-size 1)
	     (data-y 0))
	    ((<= x 0)
	     (data-y 0))
	    ((>= x 1)
	     (data-y (- half-size 1)))
	    (else
	     (let loop ((x-left (data-x 0))
			(i 1))
	       (if (= i half-size)
		   0
		   (let ((x-right (data-x i)))
		     (if (and (>= x  x-left) (<= x x-right))
			 (let ((y-left (data-y (- i 1)))
			       (y-right (data-y i)))
			   (linear-interpolate 
			    y-left 
			    y-right
			    (/ (- x x-left) (- x-right x-left))))
			 (loop x-right (+ i 1)))))))))))

;; Variant of vector-for-each.

(define (vector-iterate v p)
  (if (thunk? p)
      (integer-iterate (vector-length v) p)
      (vector-for-each p v)))

;; Return a vector of `n' places formed by applying `reader' `n' times
;; to `input-port'.

(define (vector-read n reader input-port)
  (list->vector (list-read n reader input-port)))

;; Write the objects at the vector `v' to `port' by applying `writer'
;; to the each element.

(define (vector-write v writer . port)
  (let ((port_ (if (null? port) (current-output-port) (car port))))
    (vector-for-each* (lambda (e) (writer e port_)) v)))

;; Generate a <vector> that is equal to the <vector> `v' with elements
;; at the <integer> indices `i' and `j' swapped.

(define (vector-swap v i j)
  (let ((v* (vector-copy v)))
    (vector-swap! v* i j)
    v*))

;; Mutate the <vector> v to its `n'th permutation.  This uses the same
;; swap sequence generator as 'permutation-n/seq'.

(define (vector-permute! v n)
  (let ((size (vector-length v)))
    (let loop ((i 0) (z n))
      (if (< i size)
	  (let ((j (+ i (modulo z (- size i)))))
	    (if (not (= i j)) (vector-swap! v i j))
	    (loop (+ i 1) (quotient z (- size i))))))))

(define (vector-permute v n)
  (let ((v* (vector-copy v)))
    (vector-permute! v* n)
    v*))

;; Trivial folds.

(define (vector-max v) (vector-fold (lambda (i e r) (max e r)) 0 v))
(define (vector-min v) (vector-fold (lambda (i e r) (min e r)) 2^128 v))
